home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / acall.lisp next >
Encoding:
Text File  |  2003-02-09  |  15.9 KB  |  489 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. ;;; Run-time support for translated code.
  13. ;;; GJC: Experimental macsyma array lisp level support for translated
  14. ;;; code.
  15. ;;; To quickly handle the array reference and setting syntax in macsyma,
  16.  
  17. ;;; In macsyma arrays go by an atomic name. Lists and matricies 
  18. ;;; may be hacked with the array syntax, which is convient.
  19.  
  20. ;;;additions for handling arrays in value cell on cl --wfs
  21.  
  22. (macsyma-module acall)
  23.  
  24. #+PDP10
  25. (EVAL-WHEN (EVAL COMPILE) (SSTATUS FEATURE JPG))
  26.  
  27. (TRANSL-MODULE ACALL)
  28.  
  29. (DEFMFUN INTERVAL-ERROR (FUN LOW HIGH)
  30.   (MERROR "Lower bound to ~:@M : ~M, not less than upper bound: ~M"
  31.       FUN LOW HIGH))
  32.  
  33. (DEFMFUN MFUNCALL (F &REST L)
  34.   (COND
  35.     #+cl ((functionp f)(apply f l))
  36.     #-cl ((AND (SYMBOLP F)
  37.              (FBOUNDP F))
  38.         ;; This is unfortunately NOT correct.
  39.         ;; A complicated interplay of the setting of $TRANSRUN,
  40.         ;; and MGET '$TRACE, GET 'TRANSLATED and MGET 'MEXPR
  41.         ;; interacts to determine if a function can be called
  42.         ;; via APPLY.
  43.         (APPLY F L))
  44.     #+cl
  45.     ((and (symbolp f)(or (macro-function f)
  46.              (special-operator-p f)))
  47.      (eval (cons f (copy-rest-arg l))))
  48.     (T
  49.      (MAPPLY F (copy-rest-arg  L) NIL))))
  50.  
  51. (DECLARE-TOP(*LEXPR LIST-REF))
  52.  
  53. ;;; ((MQAPPLY ARRAY) X Y) is a strange form, meaning (X)[Y].
  54.  
  55. (DEFMFUN MARRAYREF (AARRAY IND1 &REST INDS &AUX AP tem)
  56.      (declare (special FIXUNBOUND FLOUNBOUND))
  57.   (CASE
  58.     (ml-typep AARRAY)
  59.     ((ARRAY)
  60.      (CASE (ARRAY-TYPE AARRAY)
  61.         ((FLONUM FIXNUM #+LISPM ART-Q #+cl t)
  62.          (apply 'aref AARRAY IND1 INDS))
  63.         ((T)
  64.          (MARRAYREF-GENSUB AARRAY IND1 INDS))
  65.         (T
  66.           (MERROR "BUG: Non-handled array created. ~M" AARRAY))))
  67.     #-cl
  68.     ((si:equal-hash-table)
  69.      (gethash (if inds (cons ind1 inds) inds) aarray))
  70.      #+cl
  71.     ((hash-table)
  72.      (gethash (if inds (cons ind1 inds) inds) aarray))
  73.     ((SYMBOL)
  74.      (cond
  75.        #+cl
  76.        ($use_fast_arrays
  77.     (setq tem (and (boundp aarray) (symbol-value aarray)))
  78.         (simplify (cond ((arrayp tem) (apply 'aref tem ind1 inds))
  79.                 ((hash-table-p tem)
  80.                  (gethash (if inds (cons ind1 inds) inds)
  81.                     tem))
  82.                 ((EQ AARRAY 'MQAPPLY) 
  83.                  (APPLY #'MARRAYREF IND1 INDS))
  84.                 ((mget aarray 'hashar)
  85.                  (harrfind `((,aarray array) ,ind1 ,@ (copy-rest-arg inds))))
  86.                 ((symbolp tem)
  87.                  `((,tem array) ,ind1 ,@ (copy-rest-arg inds)))
  88.                 (t (error "unknown type of array for use_fast_arrays. ~
  89.                                the value cell should have the array or hash table")))))
  90.        (t
  91.         (SIMPLIFY (COND 
  92.             ((SETQ AP (GET AARRAY 'array))
  93.              (LET ((VAL (COND ((NULL INDS)
  94.                        (FUNCALL AP IND1))
  95.                       (T
  96.                        (APPLY AP IND1 INDS)))))
  97.                ;; Check for KLUDGING array function implementation.
  98.                (IF (CASE (ARRAY-TYPE AP)
  99.                       ((FLONUM) (= VAL FLOUNBOUND))
  100.                       ((FIXNUM) (= VAL FIXUNBOUND))
  101.                       ((T) (EQ VAL MUNBOUND))
  102.                       (T (MERROR "BUG: Array pointer of unknown type: ~S"
  103.                          AP)))
  104.                    (ARRFIND `((,AARRAY ,AaRRAY) ,IND1 ,@ (copy-rest-arg INDS)))
  105.                    VAL)))
  106.             ((SETQ AP (MGET AARRAY 'array))
  107.              #+JPG
  108.              (AND (MFILEP AP) (I-$UNSTORE (LIST AARRAY)))
  109.              (ARRFIND `((,AARRAY ARRAY) ,IND1 ,@ (copy-rest-arg INDS))))
  110.             ((SETQ AP (MGET AARRAY 'HASHAR))
  111.              #+JPG
  112.              (AND (MFILEP AP) (I-$UNSTORE (LIST AARRAY)))
  113.              (HARRFIND `((,AARRAY ARRAY) ,IND1  ,@ (copy-rest-arg INDS))))
  114.             ((EQ AARRAY 'MQAPPLY)
  115.              (APPLY #'MARRAYREF IND1 INDS))
  116.             (T
  117.              `((,AARRAY  ARRAY) ,IND1  ,@ (copy-rest-arg INDS))))))))
  118.     ((LIST)
  119.      (SIMPLIFY (COND ((MEMQ (CAAR AARRAY) '(MLIST $MATRIX))
  120.               (LIST-REF AARRAY (CONS IND1 (copy-rest-arg INDS))))
  121.              (T
  122.               `((MQAPPLY AARRAY) ,AARRAY ,IND1 ,@ (copy-rest-arg INDS))))))
  123.     (T
  124.       (MERROR "Bad object to reference as an array: ~M" AARRAY))))
  125.  
  126. (DEFMFUN $ARRAYAPPLY (AR INDS)
  127.   (OR ($LISTP INDS)
  128.       (MERROR "The second arg to ARRAYAPPLY must be a list."))
  129.   (APPLY #'MARRAYREF AR (CDR INDS)))
  130.  
  131. (DEFMFUN $ARRAYSETAPPLY (AR INDS VAL)
  132.   (OR ($LISTP INDS)
  133.       (MERROR "The second arg to ARRAYAPPLY must be a list."))
  134.   (APPLY #'MARRAYSET VAL AR (CDR INDS)))
  135.  
  136.  
  137. (DEFMFUN MARRAYSET (VAL AARRAY &REST ALL-INDS &AUX AP (IND1 (FIRST ALL-INDS))
  138.             (INDS (CDR ALL-INDS)))
  139.   (CASE (ml-typep AARRAY)
  140.     ((ARRAY)
  141.      (CASE (ARRAY-TYPE AARRAY)
  142.        ((FIXNUM FLONUM #+LISPM ART-Q #+cl t)
  143.     #-cl (STORE (APPLY AARRAY IND1 INDS) VAL)
  144.     #+cl (setf (apply #'aref aarray ind1 inds) val)
  145.     )
  146.        ((T)
  147.     (MARRAYSET-GENSUB VAL AARRAY IND1 INDS))
  148.        (T
  149.     (MERROR "BUG: unhandled array type. ~M" AARRAY))))
  150.     #+cl
  151.     ((hash-table #+lispm si:equal-hash-table)
  152.      (setf (gethash (if (cdr all-inds)
  153.             (copy-rest all-inds)
  154.               (car all-inds))
  155.             aarray) val))
  156.     ((SYMBOL)
  157.      (COND ((SETQ AP (GET AARRAY 'array))
  158.         (COND ((null inds)
  159.            (STORE (FUNCALL AP IND1) VAL))
  160.           (t
  161.            #-cl (STORE (APPLY AP IND1 INDS) VAL)
  162.            #+cl (setf (apply #'aref ap all-inds) val)
  163.            )))
  164.        ((SETQ AP (MGET aARRAY 'array))
  165.         #+JPG
  166.         (AND (MFILEP AP) (I-$UNSTORE (LIST aARRAY)))
  167.         ;; the macsyma ARRAY frob is NOT an array pointer, it
  168.         ;; is a GENSYM with a lisp array property, don't
  169.         ;; ask me why.
  170.         (COND ((null inds)
  171.            (store (funcall ap ind1) val))
  172.           (t
  173.            #-cl (STORE (APPLY AP ALL-INDS) VAL)
  174.            #+cl (setf (apply #'aref ap all-inds) val)
  175.            )))
  176.        ((SETQ AP (MGET aARRAY 'HASHAR))
  177.         #+JPG
  178.         (AND (MFILEP AP) (I-$UNSTORE (LIST aARRAY)))
  179.         (ARRSTORE `((,aARRAY ,'array)
  180.             ,@(MAPCAR #'(LAMBDA (U)
  181.                       `((MQUOTE SIMP) ,U))
  182.                                    all-inds
  183.                   ))
  184.               VAL))
  185.        ((EQ AaRRAY 'MQAPPLY)
  186.         #-cl
  187.         (APPLY #'MARRAYSET `(,VAL ,IND1 ,@INDS))
  188.             #+cl (apply #'marrayset val ind1 inds)
  189.         )
  190.        (T
  191.         (ARRSTORE `((,aARRAY ,'array) ,@(MAPCAR #'(LAMBDA (U)
  192.                              `((MQUOTE SIMP) ,U))
  193.                          all-inds
  194.                          ))
  195.               VAL))))
  196.     (LIST
  197.      (COND ((MEMQ (CAAR aARRAY) '(MLIST $MATRIX))
  198.         (LIST-REF aARRAY (copy-rest-arg all-inds) T VAL))
  199.        ('else
  200.         (MERROR "Bad use of `:' on~%~M" aARRAY))))
  201.     (T
  202.      (MERROR "Bad argument to set as an array.~%~M" aARRAY)))
  203.   VAL)
  204.  
  205.  
  206.  
  207. ;;; Note that all these have HEADERS on the list. The CAR of a list I
  208. ;;; will call element 0. So [1,2][1] => 1
  209.  
  210. (DEFUN LIST-REF (L INDEXL &OPTIONAL SET-FLAG VAL)
  211.   (COND ((ATOM L)
  212.      (MERROR "ERROR-> tried to take part of an atom."))
  213.     ((NULL (CDR INDEXL))
  214.      (LET ((N (CAR INDEXL)))
  215.        (COND ((AND (INTEGERP N) (PLUSP N)
  216.                (OR (EQ (CAAR L) 'MLIST)
  217.                (EQ (CAAR L) '$MATRIX)))
  218.           (LET ((RET (DO ((J 1 (f1+ J))
  219.                   (N (FIXNUM-IDENTITY N))
  220.                   (L (CDR L) (CDR L)))
  221.                  ((OR (NULL L) (= J N))
  222.                   (COND ((NULL L)
  223.                      (MERROR "Improper index to list or matrix: ~M" N))
  224.                     (SET-FLAG
  225.                      (RPLACA L VAL))
  226.                     (T
  227.                      (CAR L))))
  228.                    (DECLARE (FIXNUM J N)))))
  229.             (COND (SET-FLAG L)
  230.               (T RET))))
  231.          (T
  232.           (MERROR "ERROR-> ~M  bad part subscript." N)))))
  233.     (SET-FLAG
  234.      (LIST-REF (LIST-REF L `(,(CAR INDEXL)))
  235.            (CDR INDEXL)
  236.            SET-FLAG
  237.            VAL)
  238.      L)
  239.     (T
  240.      (LIST-REF (LIST-REF L `(,(CAR INDEXL))) (CDR INDEXL)))))
  241.  
  242. ;;; 3 guesses where this code is from.
  243. ;;;(DEFUN DISP1 (LL LABLIST EQNSP)
  244. ;;; (COND (LABLIST (SETQ LABLIST (cons '(MLIST SIMP) nil))))
  245. ;;; (DO ((LL LL (CDR LL)) (L) (ANS) ($DISPFLAG T) (TIM 0))
  246. ;;;     ((NULL LL) (OR LABLIST '$DONE))
  247. ;;;     (SETQ L (CAR LL) ANS (MEVAL L))
  248. ;;;     (COND ((AND EQNSP (OR (ATOM ANS) (NOT (EQ (CAAR ANS) 'MEQUAL))))
  249. ;;;        (SETQ ANS (LIST '(MEQUAL) (DISP2 L) ANS))))
  250. ;;;     (COND (LABLIST (COND ((NOT (CHECKLABEL $LINECHAR))
  251. ;;;                           (SETQ $LINENUM (f1+ $LINENUM))))
  252. ;;;            (MAKELABEL $LINECHAR) (NCONC LABLIST (cons LINELABLE nil))
  253. ;;;            (COND ((NOT $NOLABELS) (SET LINELABLE ANS)))))
  254. ;;;     (SETQ TIM (RUNTIME))
  255. ;;;     (DISPLA (LIST '(MLABLE) (COND (LABLIST LINELABLE)) ANS))
  256. ;;;     (MTERPRI)
  257. ;;;     (TIMEORG TIM)))
  258.  
  259. (DECLARE-TOP(SPECIAL $DISPFLAG))
  260. (DEFMFUN DISPLAY-FOR-TR (LABELSP EQUATIONSP &REST ARGL)
  261.      (declare (special LINELABLE))
  262.        (DO ((ARGL ARGL (CDR ARGL))
  263.         (LABLIST NIL)
  264.         (TIM 0))
  265.        ((NULL ARGL)
  266.         (COND (LABELSP
  267.            `((MLIST) ,@LABLIST))
  268.           (T '$DONE)))
  269.        (LET ((ANS (CAR ARGL)))
  270.         (COND ((AND EQUATIONSP
  271.                 ;; ((MEQUAL) FOO BAR)
  272.                 (NOT (ATOM (CADDR ANS)))
  273.                 (EQ (CAAR (CADDR ANS)) 'MEQUAL))
  274.                ;; if the ANS evaluats to something with an "="
  275.                ;; allready then of course he really meant to use
  276.                ;; DISP, but we might as well do what he means right?
  277.                (SETQ ANS (CADDR ANS))))
  278.         (COND (LABELSP
  279.                (OR (CHECKLABEL $LINECHAR)
  280.                (SETQ $LINENUM (f1+ $LINENUM)))
  281.                (MAKELABEL $LINECHAR)
  282.                ;; setqs the free variable LINELABLE, what a win,
  283.                ;; how convenient, now I don't need to use LET !
  284.                (PUSH LINELABLE ;; note the spelling
  285.                  LABLIST)
  286.                (OR  $NOLABELS
  287.                 (SET LINELABLE ;; SET !!!!
  288.                  ANS))))
  289.         (SETQ TIM (RUNTIME))
  290.         (DISPLA `((MLABLE) ,(COND (LABELSP LINELABLE)) ,ANS))
  291.         (MTERPRI)
  292.         (TIMEORG TIM))))
  293.  
  294.  
  295. (DEFMFUN INSURE-ARRAY-PROPS (FNNAME IGNORE-MODE NUMBER-OF-ARGS &AUX ARY)
  296.      IGNORE-MODE
  297.      ;; called during load or eval time by the defining forms
  298.      ;; for translated array-functions.
  299.      ;; this duplicates code in JPG;MLISP (however, the code in MLISP
  300.      ;; is not callable because it is in a big piece of so-called
  301.      ;; multi-purpose code).
  302.  
  303.      ;; This code is incredibly kludgy. For example, what if
  304.      ;; the function FOO[J] had a lisp array property gotten
  305.      ;; by ARRAY(FOO,FIXNUM,33), how is *THAT* detected by this code?
  306.      ;; Well, it is because that will also put an MPROP ARRAY of $FOO,
  307.      ;; and (ARRAYDIMS '$FOO) works! (Also checks the array property).
  308.      ;; Isn't that something. Shit, I never knew that ARRAYDIMS worked
  309.      ;; on symbols. What a crock.
  310.      (COND ((PROG2 (ADD2LNC FNNAME $ARRAYS)
  311.                (SETQ ARY (MGETL FNNAME '(HASHAR ARRAY))))
  312.         #+JPG
  313.         (COND ((MFILEP (CADR ARY))
  314.                (I-$UNSTORE (cons FNNAME nil))
  315.                (SETQ ARY (MGETL FNNAME '(HASHAR ARRAY)))))
  316.         (COND ((NOT (= (COND ((EQ (CAR ARY) 'HASHAR) (FUNCALL (CADR ARY) 2))
  317.                      (T (LENGTH (CDR (ARRAYDIMS (CADR ARY))))))
  318.                    NUMBER-OF-ARGS))
  319.                (MERROR
  320.             "~:@M Array already defined with different dimensions"
  321.             FNNAME))))
  322.            (T (MPUTPROP FNNAME (SETQ ARY (GENSYM)) 'HASHAR)
  323.           (*ARRAY ARY T 7)
  324.           (STORE (FUNCALL ARY 0) 4)
  325.           (STORE (FUNCALL ARY 1) 0)
  326.           (STORE (FUNCALL ARY 2) NUMBER-OF-ARGS))))
  327.  
  328. ;;; An entry point to $APPLY for translated code.
  329.  
  330. (DEFMFUN MAPPLY-TR (FUN LIST)
  331.      (OR ($LISTP LIST)
  332.          (MERROR "Second arg to APPLY was not a list:~%~M" LIST))
  333.      (MAPPLY1 FUN (CDR LIST) '|the first arg to a translated APPLY| list))
  334.  
  335.  
  336. (DEFMFUN ASSIGN-CHECK (VAR VAL)
  337.   (LET ((A (GET VAR 'ASSIGN)))
  338.     (IF A (FUNCALL A VAR VAL))))
  339.  
  340.  
  341. (declare-top (SPECIAL MAPLP))
  342.  
  343. ;(format t "~%Change maplist_tr for the explorer rest arg bug")
  344. #+cl
  345. (DEFMFUN MAPLIST_TR (FUN  L1 &rest l)
  346.   (setq l (cons l1 (copy-list l)))
  347.   (SIMPLIFY (LET ((MAPLP T) RES)
  348.           (SETQ RES (APPLY #'MAP1 (GETOPR FUN) L))
  349.           (COND ((ATOM RES) (LIST '(MLIST) RES))
  350.             ((EQ (CAAR RES) 'MLIST) RES)
  351.             (T (CONS '(MLIST) (MARGS RES))))))) 
  352. #-cl
  353. (DEFMFUN MAPLIST_TR (FUN &REST L)
  354.   (SIMPLIFY (LET ((MAPLP T) RES)
  355.           (SETQ RES (APPLY #'MAP1 (GETOPR FUN) L))
  356.           (COND ((ATOM RES) (LIST '(MLIST) RES))
  357.             ((EQ (CAAR RES) 'MLIST) RES)
  358.             (T (CONS '(MLIST) (MARGS RES)))))))
  359.  
  360.  
  361. ;;; Entry point into DB for translated code. The main point here
  362. ;;; is that evaluation of a form takes place first, (using the lisp
  363. ;;; evaluator), and then the trueness is checked. It is not correct
  364. ;;; to call the function IS because double-evaluation will then
  365. ;;; result, which is wrong, not to mention being incompatible with
  366. ;;; the interpreter. 
  367. ;;;
  368. ;;; This code is take from the COMPAR module, and altered such that calls to
  369. ;;; the macsyma evaluator do not take place. It would be a lot
  370. ;;; better to simply modify the code in COMPAR! However, mumble...
  371. ;;; Anyway, be carefull of changes to COMPAR that break this code.
  372.  
  373. (DEFMFUN IS-BOOLE-CHECK (FORM)
  374.   (COND ((NULL FORM) NIL)
  375.     ((EQ FORM T) T)
  376.     ('ELSE
  377.      ;; We check for T and NIL quickly, otherwise go for the database.
  378.      (MEVALP_TR FORM T NIL))))
  379.  
  380. (DEFMFUN MAYBE-BOOLE-CHECK (FORM)
  381.   (MEVALP_TR FORM NIL NIL))
  382.  
  383. ;; The following entry point is for querying the database without
  384. ;; the dubious side effects of using PREDERROR:FALSE.
  385.  
  386. (DEFMSPEC $MAYBE (FORM) (MEVALP_TR (FEXPRCHECK FORM) NIL T))
  387.  
  388. (DECLARE-TOP(SPECIAL PATEVALLED))
  389.  
  390. (defun mevalp_tr (pat error? meval?)
  391.   (let (patevalled ans)
  392.     (setq ans (mevalp1_tr pat error? meval?))
  393.     (cond ((memq ans '(t nil)) ans)
  394.       (error?
  395.        (pre-err patevalled))
  396.       ('else '$UNKNOWN))))
  397.  
  398. (defun mevalp1_tr (pat error? meval?)
  399.   (cond ((and (not (atom pat)) (memq (caar pat) '(mnot mand mor)))
  400.      (cond ((eq 'mnot (caar pat)) (is-mnot_tr (cadr pat) error? meval?))
  401.            ((eq 'mand (caar pat)) (is-mand_tr (cdr pat) error? meval?))
  402.            (t (is-mor_tr (cdr pat) error? meval?))))
  403.     ((atom (setq patevalled (if meval? (meval pat) pat))) patevalled)
  404.     ((memq (caar patevalled) '(mnot mand mor)) (mevalp1_tr patevalled
  405.                                    error?
  406.                                    meval?))
  407.     (t (mevalp2 (caar patevalled) (cadr patevalled) (caddr patevalled)))))
  408.  
  409. (defun is-mnot_tr (pred error? meval?)
  410.   (setq pred (mevalp_tr pred error? meval?))
  411.   (cond ((eq t pred) nil)
  412.     ((not pred))
  413.     (t (pred-reverse pred))))
  414.  
  415. (defun is-mand_tr (pl error? meval?)
  416.   (do ((dummy) (npl))
  417.       ((null pl) (cond ((null npl))
  418.                ((null (cdr npl)) (car npl))
  419.                (t (cons '(mand) (nreverse npl)))))
  420.     (setq dummy (mevalp_tr (car pl) error? meval?)
  421.       pl (cdr pl))
  422.     (cond ((eq t dummy))
  423.       ((null dummy) (return nil))
  424.       (t (setq npl (cons dummy npl))))))
  425.  
  426. (defun is-mor_tr (pl error? meval?)
  427.   (do ((dummy) (npl))
  428.       ((null pl) (cond ((null npl) nil)
  429.                ((null (cdr npl)) (car npl))
  430.                (t (cons '(mor) (nreverse npl)))))
  431.     (setq dummy (mevalp_tr (car pl) error? meval?)
  432.       pl (cdr pl))
  433.     (cond ((eq t dummy) (return t))
  434.       ((null dummy))
  435.       (t (setq npl (cons dummy npl))))))
  436.  
  437.  
  438. ;; Some functions for even faster calling of arrays.
  439. (DECLARE-TOP(FLONUM (MARRAYREF1$ NIL NIL)
  440.          (MARRAYSET1$ FLONUM NIL NIL)))
  441.  
  442. (DEFUN MARRAYREF1$ (AARRAY INDEX)
  443.   (CASE (ml-typep AARRAY)
  444.     ((AARRAY)
  445.      (CASE (ARRAY-TYPE AARRAY)
  446.        ((FLONUM) (ARRAYCALL FLONUM AARRAY INDEX))
  447.        (T (MERROR "Bad type of array to call for FLOAT value: ~M" AARRAY))))
  448.     (T
  449.      (FLOAT (MARRAYREF AARRAY INDEX)))))
  450.  
  451. (DEFUN MARRAYSET1$ (VALUE AARRAY INDEX)
  452.   (CASE (ml-typep AARRAY)
  453.     ((AARRAY)
  454.      (CASE (ARRAY-TYPE AARRAY)
  455.        ((FLONUM) (STORE (ARRAYCALL FLONUM AARRAY INDEX) VALUE))
  456.        (T (MERROR "Bad type of array to set FLOAT into: ~M" AARRAY))))
  457.     (T
  458.      (FLOAT (MARRAYSET VALUE AARRAY INDEX)))))
  459.  
  460.  
  461. (DEFMFUN APPLICATION-OPERATOR (FORM &rest ign) ign 
  462.   (APPLY (CAAR FORM) (CDR FORM)))
  463.  
  464. ;;; Multics trys to optimize EVAL calls into APPLY's 
  465. ;;; On Multics DEFUN is a MACRO so we indirect to fool the complier
  466. ;;; by letting the form be a variable.
  467. (DEFMFUN MAKE-ALAMBDA (FORMALS BODY)
  468.   (LET* ((NAME (GENSYM))
  469.      (FORM-TO-EVAL `(DEFUN ,NAME ,FORMALS ,BODY)))
  470.     ;; on LISPM we can use closures after we fix up MEVAL and MAPPLY.
  471.     ;; This isn't much more expensive, GENSYMs get garbage collected
  472.     ;; just like any other object.
  473.     (PUTPROP NAME 'APPLICATION-OPERATOR 'OPERATORS)
  474.     (EVAL `(DEFUN ,NAME ,FORMALS ,BODY))
  475.     (EVAL FORM-TO-EVAL)
  476.     NAME))
  477.  
  478. ;; more efficient operators calls.
  479.  
  480. (DEFUN *MMINUS (X)
  481.   (IF (NUMBERP X)
  482.       (MINUS X)
  483.       (SIMPLIFY (LIST '(MMINUS) X))))
  484.  
  485. (DEFmfUN RETLIST_TR N
  486.   (DO ((J (f1- N) (f- J 2))
  487.        (L () (CONS (LIST '(MEQUAL SIMP) (ARG J) (ARG (f1+ J))) L)))
  488.       ((< J 0) (CONS '(MLIST SIMP) L))))
  489.